{
  This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
  the Free Software Foundation; version 2 of the License.
   
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.
}

// Copyright (c) 2010 2011 2012 - J. Aldo G. de Freitas Junior

{$mode objfpc}
{$H+}

Unit
	XMLScanner;

Interface

Uses
	Classes,
	SysUtils,
	BaseException,
	StrUtils,
	Stacks;

Type
	TXMLSource = Class
	Private
		fSource : TStream;
		fTempRow,
		fTempCol,
		fRow,
		fCol : Integer;
		fNext : Char;
		fSourceName : String;
	Public
		Constructor Create(Const aSourceName : String; Const aSource : TStream);
		Property Row : Integer Read fRow;
		Property Col : Integer Read fCol;
		Procedure Mark;
		Procedure HardGetNext;
		Procedure SoftGetNext;
		Function IsEOF : Boolean;
		Procedure RaiseError(Const aMsg : String);
		// Properties
		Property Next : Char Read fNext;
		Property SourceName : String Read fSourceName Write fSourceName;
	End;
	
	TXMLTokenKind = (
			tkXMLWhite,
			tkXMLOpenTag,
			tkXMLCloseTag,
			tkXMLIdentifier,
			tkXMLText,
			tkXMLString,
			tkXMLSlash,
			tkXMLExclamation,
			tkXMLQuestion,
			tkXMLEqual,
			tkXMLEOF
		);

	TXMLToken = Record
		Literal,
		Source : String;
		Row,
		Col     : Integer;
		Kind    : TXMLTokenKind;
	End;
	
	TXMLTokenArray = Array Of TXMLToken;

	TXMLScanner = Class
	Private
		fSource : TXMLSource;
		fDestination : TXMLTokenArray;
		Procedure AppendToOutput(Const aLiteral : String; Const aKind : TXMLTokenKind);
		Procedure ScanWhite;
		Procedure ScanIdentifier;
		Procedure ScanString;
		Procedure ScanText;
		Procedure ScanPunct;
		Procedure ScanTag;
	Public
		Constructor Create(Const aSource : TXMLSource);
		Procedure Scan;
		// Properties
		Property Destination : TXMLTokenArray Read fDestination;
	End;
	
	TXMLTokenIterator = Class
	Private
		fStack : TIntegerStack;
		fSource : TXMLTokenArray;
		fPosition : Integer;
		fKind : TXMLTokenKind;
		fLiteral : String;
		fRow,
		fCol : Integer;
		fSourceName : String;
	Public
		Constructor Create(Const aSource : TXMLTokenArray);
		Destructor Destroy; Override;
		Procedure Load;
		Procedure Next;
		Procedure Mark;
		Procedure Recall;
		Function Expected(Const aLiteral : String; Const aHaltIfNotFound : Boolean = False): Boolean; Overload;
		Function Expected(Const aKind : TXMLTokenKind; Const aHaltIfNotFound : Boolean = False): Boolean; Overload;
		Function Consume(Const aLiteral : String; Const aHaltIfNotFound : Boolean = True): Boolean; Overload;
		Function Consume(Const aKind : TXMLTokenKind; Const aHaltIfNotFound : Boolean = True): Boolean; Overload;
		Function ConsumeElse(Const aLiteral, aAlternative : String): Boolean;
		Function Match(Const aKinds : Array Of TXMLTokenKind): Boolean;
		Function Extract(Const aKind : TXMLTokenKind): String;
		Function IsEOS: Boolean;
		Procedure RaiseError(Const aMsg : String);
		// Properties
		Property Kind : TXMLTokenKind Read fKind;
		Property Literal : String Read fLiteral;
		Property Row : Integer Read fRow;
		Property Col : Integer Read fCol;
		Property SourceName : String Read fSourceName Write fSourceName;
	End;
	
Implementation

// TXMLSource

Constructor TXMLSource.Create(Const aSourceName : String; Const aSource : TStream);
Begin
	Inherited Create;
	fSource := aSource;
	fTempRow := 1;
	fTempCol := 0;
	fRow := 1;
	fCol := 0;
	fNext := #00;
End;
	
Procedure TXMLSource.Mark;
Begin
	fRow := fTempRow;
	fCol := fTempCol;
End;
	
Procedure TXMLSource.HardGetNext;
Begin
	Try
		fNext := Char(fSource.ReadByte);
	Except
		On E: Exception Do 
			fNext := #00;
	End;
End;
	
Procedure TXMLSource.SoftGetNext;
Begin
	HardGetNext;
	Case fNext Of
		#13 :
			fTempCol := 1;
		#10 :
		Begin
			fTempCol := 1;
			fTempRow := fTempRow + 1;
		End;
	Else
		fTempCol := fTempCol + 1;
	End;
End;

Function TXMLSource.IsEOF: Boolean;
Begin
	Result := fSource.Position >= fSource.Size;
End;

Procedure TXMLSource.RaiseError(Const aMsg : String);
Var
	lException : EInterpreterException;
Begin
	lException := EInterpreterException.Create(fRow, fCol, fSourceName, Nil);
	lException.AddTrace(fRow, fCol, fSourceName, aMsg);
	Raise lException;
End;

// TXMLScanner

Procedure TXMLScanner.AppendToOutput(Const aLiteral : String; Const aKind : TXMLTokenKind);
Var
	lToken : TXMLToken;
Begin
	If (aKind = tkXMLString) Or Not(IsEmptyStr(aLiteral, [#32, #13, #10, #09])) Then
	Begin
		// Debug  WriteLn('(', fSource.Row:3, ':', fSource.Col:3, ') "', aLiteral, '" -> ', aKind);
		lToken.Source := fSource.SourceName;
		lToken.Col := fSource.Col;
		lToken.Row := fSource.Row;
		lToken.Literal := aLiteral;
		lToken.Kind := aKind;
		SetLength(fDestination, Length(fDestination) + 1);
		fDestination[High(fDestination)] := lToken;
	End;
End;

Procedure TXMLScanner.ScanWhite;
Begin
	fSource.Mark;
	While (fSource.Next In [#32, #09, #13, #10]) And Not(fSource.IsEOF) Do
		fSource.SoftGetNext;
	// AppendToOutput('', tkXMLWhite);
End;

Procedure TXMLScanner.ScanIdentifier;
Var
	fLiteral : String;
Begin
	fLiteral := '';
	fSource.Mark;
	While (fSource.Next In ['a'..'z', 'A'..'Z', '0'..'9', '-', '_']) And Not(fSource.IsEOF) Do
	Begin
		fLiteral := fLiteral + fSource.Next;
		fSource.SoftGetNext;
	End;
	AppendToOutput(fLiteral, tkXMLIdentifier);
End;

Procedure TXMLScanner.ScanString;
Var
	fLiteral : String;
Begin
	fLiteral := '';
	fSource.Mark;
	fSource.SoftGetNext;
	While (fSource.Next <> '"') And Not(fSource.IsEOF) And Not(fSource.Next In [#13, #10]) Do
	Begin
		fLiteral := fLiteral + fSource.Next;
		fSource.SoftGetNext;
	End;
	If fSource.Next = '"' Then
	Begin
		AppendToOutput(fLiteral, tkXMLString);
		fSource.SoftGetNext;
	End
	Else
		If fSource.Next In [#13, #10] Then
			fSource.RaiseError('String exceeds line.')
		Else
			fSource.RaiseError('Unexpected end of file.');
End;

Procedure TXMLScanner.ScanText;
Var
	fLiteral : String;
Begin
	fLiteral := '';
	fSource.Mark;
	While (fSource.Next <> '<') And Not(fSource.IsEOF) Do
	Begin
		fLiteral := fLiteral + fSource.Next;
		fSource.SoftGetNext;
	End;
	fLiteral := AdjustLineBreaks(DelSpace1(fLiteral));
	AppendToOutput(fLiteral, tkXMLText);
End;

Procedure TXMLScanner.ScanPunct;
Begin
	fSource.Mark;
	Case fSource.Next Of
	'<' :
		Begin
			AppendToOutput('<', tkXMLOpenTag);
			fSource.SoftGetNext;
		End;
	'>' :
		Begin
			AppendToOutput('>', tkXMLCloseTag);
			fSource.SoftGetNext;
		End;
	'!' :
		Begin
			AppendToOutput('!', tkXMLExclamation);
			fSource.SoftGetNext;
		End;
	'?' :
		Begin
			AppendToOutput('?', tkXMLQuestion);
			fSource.SoftGetNext;
		End;
	'/' :
		Begin
			AppendToOutput('/', tkXMLSlash);
			fSource.SoftGetNext;
		End;
	'=' :
		Begin
			AppendToOutput('=', tkXMLEqual);
			fSource.SoftGetNext;
		End;
	End;
End;

Procedure TXMLScanner.ScanTag;
Begin
	If fSource.Next = '<' Then
		ScanPunct;
	While (fSource.Next <> '>') And Not(fSource.IsEOF) Do
	Begin
		If fSource.Next In [#32, #09, #13, #10] Then
			ScanWhite
		Else If fSource.Next In ['a'..'z', 'A'..'Z', '0'..'9', '-', '_'] Then
			ScanIdentifier
		Else If fSource.Next In ['/', '!', '?', '='] Then
			ScanPunct
		Else If fSource.Next = '"' Then
			ScanString
		Else If fSource.Next In [#13, #10] Then
			fSource.RaiseError('Tag exceeds end of line.')
		Else
			fSource.RaiseError('Unknow char at input.');
	End;
	If fSource.Next = '>' Then
		ScanPunct
	Else
		fSource.RaiseError('Tag exceeds end of file.');
End;

Constructor TXMLScanner.Create(Const aSource : TXMLSource);
Begin
	Inherited Create;
	fSource := aSource;
	SetLength(fDestination, 0);
End;

Procedure TXMLScanner.Scan;
Begin
	fSource.SoftGetNext;
	While Not(fSource.IsEOF) Do
		If fSource.Next = '<' Then
			ScanTag
		Else
			ScanText;
	AppendToOutput('', tkXMLEOF);
End;

// TXMLTokenIterator

Constructor TXMLTokenIterator.Create(Const aSource : TXMLTokenArray);
Begin
	Inherited Create;
	fStack := TIntegerStack.Create;
	fPosition := 0;
	fSource := aSource;
	fLiteral := '';
	fRow := 0;
	fCol := 0;
	fSourceName := 'Unknown';
	Load;
End;

Destructor TXMLTokenIterator.Destroy;
Begin
	fStack.Free;
	Inherited Destroy;
End;

Procedure TXMLTokenIterator.Load;
Begin
	If (fPosition >= Low(fSource)) And (fPosition <= High(fSource)) Then
	Begin
		fLiteral := fSource[fPosition].Literal;
		fSourceName := fSource[fPosition].Source;
		fRow := fSource[fPosition].Row;
		fCol := fSource[fPosition].Col;
		fKind := fSource[fPosition].Kind;
	End;
End;

Procedure TXMLTokenIterator.Next;
Begin
	If fPosition < High(fSource) Then
	Begin
		Inc(fPosition);
		Load;
	End
	Else
	Begin
		fKind := tkXMLEOF;
		fLiteral := '';
	End;
	// Debug  WriteLn('Position : ', fPosition, ' Size : ', Length(fSource));
	// Debug  WriteLn('Literal : ', fLiteral, ' Kind : ', fKind);
End;

Procedure TXMLTokenIterator.Mark;
Begin
	// Debug WriteLn('Pushing positon : ', fPosition);
	fStack.Push(fPosition);
End;

Procedure TXMLTokenIterator.Recall;
Begin
	// Debug WriteLn('Returning to position : ', fStack.Top);
	fPosition := fStack.Pop;
	Load;
End;

Function TXMLTokenIterator.Expected(Const aLiteral : String; Const aHaltIfNotFound : Boolean = False): Boolean;
Begin
	Result := fLiteral = aLiteral;
	If aHaltIfNotFound And Not(Result) Then
		RaiseError('Expected ' + aLiteral + '.')
End;

Function TXMLTokenIterator.Expected(Const aKind : TXMLTokenKind; Const aHaltIfNotFound : Boolean = False): Boolean;
Begin
	Result := fKind = aKind;
	If aHaltIfNotFound And Not(Result) Then
		Case aKind Of 
			tkXMLWhite       : RaiseError('Expected whitespace.');
			tkXMLOpenTag     : RaiseError('Expected "<".');
			tkXMLCloseTag    : RaiseError('Expected ">".');
			tkXMLIdentifier  : RaiseError('Expected identifier.');
			tkXMLText        : RaiseError('Expected text.');
			tkXMLString      : RaiseError('Expected string.');
			tkXMLSlash       : RaiseError('Expected "/".');
			tkXMLExclamation : RaiseError('Expected "!".');
			tkXMLQuestion    : RaiseError('Expected "?".');
			tkXMLEqual       : RaiseError('Expected "=".');
			tkXMLEOF         : RaiseError('Expected end of source.');
		End;
End;

Function TXMLTokenIterator.Consume(Const aLiteral : String; Const aHaltIfNotFound : Boolean = True): Boolean;
Begin
	// Debug WriteLn('Consuming ', aLiteral);
	Result := Expected(aLiteral, aHaltIfNotFound);
	If Result Then
		Next;
End;

Function TXMLTokenIterator.Consume(Const aKind : TXMLTokenKind; Const aHaltIfNotFound : Boolean = True): Boolean;
Begin
	// Debug WriteLn('Consuming ', aKind);
	Result := Expected(aKind, aHaltIfNotFound);
	If Result Then
		Next;
End;

Function TXMLTokenIterator.ConsumeElse(Const aLiteral, aAlternative : String): Boolean;
Begin
	Result := Consume(aLiteral, False);
	If Not(Result) Then
		Consume(aAlternative, True);
End;

Function TXMLTokenIterator.Match(Const aKinds : Array Of TXMLTokenKind): Boolean;
Var
	lCtrl : Integer;
Begin
	// Debug  WriteLn('Matching :');
	Mark;
	Result := True;
	For lCtrl := Low(aKinds) To High(aKinds) Do
	Begin
		// Debug  WriteLn(fKind, '->', aKinds[lCtrl]);
		Result := Result And (fKind = aKinds[lCtrl]);
		Next;
	End;
	Recall;
End;

Function TXMLTokenIterator.Extract(Const aKind : TXMLTokenKind): String;
Begin
	// Debug WriteLn('Extracting ', aKind, ' got ', fKind, ' string "', fLiteral, '".');
	Result := fLiteral;
	Consume(aKind);
End;

Function TXMLTokenIterator.IsEOS: Boolean;
Begin
	Result := fPosition >= High(fSource);
End;

Procedure TXMLTokenIterator.RaiseError(Const aMsg : String);
Var
	lException : EInterpreterException;
Begin
	lException := EInterpreterException.Create(fRow, fCol, fSourceName, Nil);
	lException.AddTrace(fRow, fCol, fSourceName, aMsg);
	Raise lException;
End;


End.